home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / sorts.com / SORTST1.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-09-22  |  2.8 KB  |  98 lines
  1. program SortsT1;                           { Turbo Pascal 5.0, 5.5 }
  2. {$S-,R-}
  3.  
  4. { Test program for Sorts unit to show the ascending/descending sorts and sort
  5.   times with the QSort procedure.  }
  6.  
  7. uses Sorts;
  8.  
  9. type
  10.   ArrayType =  array[0..32759] of integer;           {must start with 0}
  11.  
  12. var
  13.   Time : longint absolute $0040:$006C;               {1 count = 55.9 Msec}
  14.   Tick1 : longint;
  15.   L1 : ^ArrayType;           {pointer to array}
  16.   I : integer;
  17.   LstLen,Repeats,RanLimit,WriteLen : integer;
  18.   ElTime : real;
  19.  
  20. {$F+} function Comp1(var X1,X2) : boolean;    {compare for sort ascending}
  21. begin
  22.   if integer(X1) < integer(X2) then Comp1 := true else Comp1 := false;
  23. end;  {$F-}
  24.  
  25. {$F+} function Comp2(var X1,X2) : boolean;    {compare for sort decending}
  26. begin
  27.   if integer(X1) > integer(X2) then Comp2 := true else Comp2 := false;
  28. end;  {$F-}
  29.  
  30. procedure GenerateList;
  31. var
  32.   J : integer;
  33. begin
  34.   RandSeed := 1;
  35.   for J := 0 to LstLen-1 do L1^[J] := Random(RanLimit)
  36. end;
  37.  
  38. procedure WriteList(SortType : string; Mode : byte);
  39. var
  40.   I : integer;
  41. begin
  42.   ElTime := (Time - Tick1) * 55.9;
  43.   if LstLen > WriteLen then
  44.     begin
  45.       case Mode of
  46.         0 : Writeln(SortType,' 1st and last ',WriteLen,' items:');
  47.         1 : Writeln(SortType,ElTime:1:1,' MSec, 1st and ',
  48.                                                  'last ',WriteLen,' items:');
  49.       end;
  50.       for I := 0 to WriteLen-1 do Write(L1^[I],' ');
  51.       Writeln;
  52.       for I := LstLen - WriteLen to LstLen-1 do Write(L1^[I],' ');
  53.       Writeln;
  54.     end
  55.   else
  56.     begin
  57.       case Mode of
  58.         0 : Writeln(SortType,' ',LstLen,' item(s):');
  59.         1 : Writeln(SortType,ElTime:1:1,' MSec, ',LstLen,' item(s):');
  60.       end;
  61.       for I := 0 to LstLen-1 do Write(L1^[I],' ');
  62.       Writeln;
  63.     end;
  64. end;
  65.  
  66. begin
  67.   WriteLen := 15;     {number of items to write to display}
  68.   RanLimit := 10000;
  69.   New(L1);
  70.   repeat
  71.     Write(#13,#10,'Enter list size (1-32759) or 0 to quit: ');
  72.     Readln(LstLen);
  73.     if (LstLen <= 0) or (LstLen > 32759) then Exit;
  74.     Write('Enter list repeats (1-3000) or 0 to quit: ');
  75.     ReadLn(Repeats);
  76.     if (Repeats <= 0) or (Repeats > 3000) then Exit;
  77.     Writeln('Sorting random integers in range 1 - ',RanLimit,' in list of ',
  78.                                    LstLen,' items ',Repeats,' time(s).');
  79.     GenerateList;
  80.     WriteList('Unsorted:     ',0);
  81.     Tick1 := Time;
  82.     for I := 1 to Repeats do
  83.       begin
  84.         GenerateList;
  85.         QSort(L1,0,LstLen-1,SizeOf(integer),Comp1);
  86.       end;
  87.     WriteList('Sort Ascending:  ',1);
  88.     Tick1 := Time;
  89.     for I := 1 to Repeats do
  90.       begin
  91.         GenerateList;
  92.         QSort(L1,0,LstLen-1,SizeOf(integer),Comp2);
  93.       end;
  94.     WriteList('Sort Descending: ',1);
  95.   until false;
  96.   Dispose(L1);
  97. end.
  98.